home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / bfl / bfl.lha / cfortran.h < prev    next >
C/C++ Source or Header  |  1992-10-28  |  72KB  |  1,527 lines
  1. /* cfortran.h */ /* 2.4 */            /* anonymous ftp: zebra.desy.de */
  2. /* Burkhard Burow, burow@vxdesy.cern.ch, University of Toronto, 1992. */
  3.  
  4. #ifndef __CFORTRAN_LOADED
  5. #define __CFORTRAN_LOADED
  6.  
  7. /* 
  8.    THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU
  9.    SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING,
  10.    MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE.
  11. */
  12.  
  13. /* Before using cfortran.h on CRAY, RS/6000, Apollo >=6.8, gcc -ansi,
  14.    or any other ANSI C compiler, you must once do:
  15. prompt> mv cfortran.h cf_temp.h && sed 's/\/\*\*\//##/g' cf_temp.h >cfortran.h
  16.    i.e. we change the ' / * * / ' kludge to ##. */
  17.  
  18. /* First prepare for the C compiler. */
  19.  
  20. #if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__))
  21. #define VAXUltrix
  22. #endif
  23.  
  24. #include <stdio.h>     /* NULL [in all machines stdio.h]                      */
  25. #include <string.h>    /* strlen, memset, memcpy, memchr.                     */
  26. #if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
  27. #include <stdlib.h>    /* malloc,free                                         */
  28. #else
  29. #include <malloc.h>    
  30. #ifdef apollo
  31. #define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */
  32. #endif
  33. #endif
  34.  
  35. #if (!defined(__GNUC__) && (defined(__hp9000s300)||defined(sun)||defined(VAXUltrix)||defined(lynx)))
  36. #define __CF__KnR     /* HP, Sun, LynxOS and VAX Ultrix cc only supports K&R. */
  37. #endif                /*       i.e. We will generate Kernighan and Ritchie C. */
  38. /* Note that you may define __CF__KnR before #include cfortran.h, in order to
  39. generate K&R C instead of the default ANSI C. The differences are mainly in the
  40. function prototypes and declarations. All machines, except the Apollo, work
  41. with either style. The Apollo's argument promotion rules require ANSI or use of
  42. the obsolete std_$call which we have not implemented here. Hence on the Apollo,
  43. only C calling FORTRAN subroutines will work using K&R style.*/
  44.  
  45.  
  46. /* Remainder of cfortran.h depends on the Fortran compiler. */
  47.  
  48. /* VAX/VMS does not let us \-split these long lines. */ 
  49. #if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hp9000s300Fortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)||defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran))
  50. /* If no Fortran compiler is given, we choose one for the machines we know.   */
  51. #if defined(lynx) || defined(VAXUltrix)
  52. #define f2cFortran    /* Lynx:      Only support f2c at the moment.
  53.                          VAXUltrix: f77 behaves like f2c.
  54.                            Support f2c or f77 with gcc, vcc with f2c. 
  55.                            f77 with vcc works, missing link magic for f77 I/O.*/
  56. #endif
  57. #if defined(__hp9000s300)
  58. #define       hp9000s300Fortran
  59. #endif
  60. #if       defined(apollo)
  61. #define           apolloFortran  /* __CF__APOLLO67 defines some behavior. */
  62. #endif
  63. #if          defined(sun)
  64. #define              sunFortran
  65. #endif
  66. #if       defined(_IBMR2)
  67. #define            IBMR2Fortran
  68. #endif
  69. #if        defined(_CRAY)
  70. #define             CRAYFortran  /* _CRAY2         defines some behavior. */
  71. #endif
  72. #if         defined(mips) || defined(__mips)
  73. #define             mipsFortran
  74. #endif
  75. #if          defined(vms)
  76. #define              vmsFortran
  77. #endif
  78. #endif /* ...Fortran */
  79.  
  80. #if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hp9000s300Fortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)||defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran))
  81. ??=error cfortran.h supports the following machines/OS/compilers:
  82. ??=error - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...)
  83. ??=error - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000
  84. ??=error - VAX VMS CC 3.1 and FORTRAN 5.4.
  85. ??=error - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7.
  86. ??=error - CRAY
  87. ??=error - Sun
  88. ??=error - HP9000s300
  89. ??=error - LynxOS: cc or gcc with f2c.
  90. ??=error - VAX Ultrix: vcc,cc or gcc with f2c. gcc or cc with f77.
  91. ??=error -             f77 with vcc works; but missing link magic for f77 I/O.
  92. ??=error -             NO fort. None of gcc, cc or vcc generate required names.
  93. ??=error - f2c    : Use #define    f2cFortran, or cc -Df2cFortran
  94. ??=error - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran
  95. #else   /* #endif is 2nd last line of file. */
  96.  
  97. /* Throughout cfortran.h we use: UN = Uppercase Name.  LN = Lowercase Name.  */
  98.  
  99. #if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || (defined(IBMR2Fortran) && defined(extname))
  100. #define CFC_(UN,LN)            LN/**/_   /* Lowercase FORTRAN symbols.        */
  101. #define orig_fcallsc           CFC_
  102. #else 
  103. #ifdef CRAYFortran
  104. #define CFC_(UN,LN)            UN        /* Uppercase FORTRAN symbols.        */
  105. #define orig_fcallsc(UN,LN)    CFC_(UN,LN)  /* CRAY insists on arg.'s here.   */
  106. #else  /* For following machines one may wish to change the fcallsc default.  */
  107. #define CF_SAME_NAMESPACE
  108. #ifdef vmsFortran
  109. #pragma nostandard                       /* To avoid %CC-I-PARAMNOTUSED.      */
  110. #define CFC_(UN,LN)            LN        /* Either case FORTRAN symbols.      */
  111.      /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/
  112.      /* because VAX/VMS doesn't do recursive macros.                          */
  113. #define orig_fcallsc(UN,LN)    UN      
  114. #pragma standard                         /* Have avoided %CC-I-PARAMNOTUSED.  */
  115. #else                   /* HP, or IBMR2&&!-qextname which isn't reccomended.  */
  116. #define CFC_(UN,LN)            LN        /* Lowercase FORTRAN symbols.        */
  117. #define orig_fcallsc           CFC_
  118. #endif /*  vmsFortran */
  119. #endif /* CRAYFortran */
  120. #endif /* ....Fortran */
  121.  
  122. #define fcallsc                      orig_fcallsc
  123. #define preface_fcallsc(P,p,UN,LN)   CFC_(P/**/UN,p/**/LN)
  124. #define  append_fcallsc(P,p,UN,LN)   CFC_(UN/**/P,LN/**/p)
  125.  
  126. #define C_FUNCTION                   fcallsc      
  127. #define FORTRAN_FUNCTION             CFC_
  128. #define COMMON_BLOCK                 CFC_
  129.  
  130. #if defined(NAGf90Fortran) || defined(f2cFortran) || defined(mipsFortran)
  131. #define LOGICAL_STRICT      /* These have .eqv./.neqv. == .eq./.ne.   */
  132. #endif
  133.  
  134. #ifdef CRAYFortran
  135. #if _CRAY
  136. #include <fortran.h>
  137. #else
  138. #include "fortran.h"  /* i.e. if crosscompiling assume user has file. */
  139. #endif
  140. #define DOUBLE_PRECISION long double
  141. #define PPFLOATVV (float *)/* Used for C calls FORTRAN. CRAY's double==float but
  142.                             CRAY says pointers to doubles and floats are diff.*/
  143. #define VOIDP  (void *)  /* When FORTRAN calls C, we don't know if C routine 
  144.                             arg.'s have been declared float *, or double *.   */
  145. #else
  146. #define DOUBLE_PRECISION double
  147. #define PPFLOATVV
  148. #define VOIDP
  149. #endif
  150.  
  151. #ifdef vmsFortran
  152. #if    vms
  153. #include <descrip.h>
  154. #else
  155. #include "descrip.h"  /* i.e. if crosscompiling assume user has file. */
  156. #endif
  157. #endif
  158.  
  159. #ifdef sunFortran
  160. #if    sun
  161. #include <math.h>     /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT.  */
  162. #else
  163. #include "math.h"     /* i.e. if crosscompiling assume user has file. */
  164. #endif
  165. #endif
  166.  
  167. #ifndef apolloFortran
  168. #define COMMON_BLOCK_DEF(DEFINITION, NAME) extern DEFINITION NAME
  169. #define CF_NULL_PROTO
  170. #else                                         /* HP doesn't understand #elif. */
  171. /* Without ANSI prototyping, Apollo promotes float functions to double.    */
  172. /* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */
  173. #define CF_NULL_PROTO ...
  174. #ifndef __CF__APOLLO67
  175. #define COMMON_BLOCK_DEF(DEFINITION, NAME) \
  176.  DEFINITION NAME __attribute((__section(NAME)))
  177. #else
  178. #define COMMON_BLOCK_DEF(DEFINITION, NAME) \
  179.  DEFINITION NAME #attribute[section(NAME)]
  180. #endif
  181. #endif
  182.  
  183. #ifdef mipsFortran
  184. #define CF_DECLARE_GETARG         int f77argc; char **f77argv
  185. #define CF_SET_GETARG(ARGC,ARGV)  f77argc = ARGC; f77argv = ARGV
  186. #else
  187. #if defined(VAXC) && defined(vms)        
  188. #pragma nostandard                       /* To avoid %CC-I-PARAMNOTUSED.      */
  189. #endif
  190. #define CF_DECLARE_GETARG
  191. #define CF_SET_GETARG(ARGC,ARGV)
  192. #if defined(VAXC) && defined(vms)        
  193. #pragma standard                         /* Have avoided %CC-I-PARAMNOTUSED.  */
  194. #endif
  195. #endif
  196.  
  197. #define ACOMMA ,
  198. #define ACOLON ;
  199.  
  200. /*-------------------------------------------------------------------------*/
  201.  
  202. /*               UTILITIES USED WITHIN CFORTRAN.H                          */
  203.  
  204. #define MIN(A,B) (A<B?A:B)
  205. #define firstindexlength( A) (sizeof(A)     /sizeof(A[0]))
  206. #define secondindexlength(A) (sizeof((A)[0])/sizeof((A)[0][0]))
  207. #ifndef FALSE
  208. #define FALSE (1==0)
  209. #endif
  210.  
  211. /* Behavior of FORTRAN LOGICAL. All machines' LOGICAL is same size as C's int.
  212. Conversion is automatic except for arrays which require F2CLOGICALV/C2FLOGICALV.
  213. f2c, MIPS f77 [DECstation, SGI], VAX Ultrix f77, CRAY-2, HP-UX f77:  as in C.
  214. VAX/VMS FORTRAN, VAX Ultrix fort, IBM RS/6000 xlf: LS Bit = 0/1 = TRUE/FALSE.
  215. Apollo, non CRAY-2                               : neg.   = TRUE, else FALSE. 
  216. [Apollo accepts -1 as TRUE for function values, but NOT all other neg. values.]
  217. [DECFortran for Ultrix RISC is also called f77 but is the same as VAX/VMS.]   
  218. [MIPS f77 treats .eqv./.neqv. as .eq./.ne. and hence requires LOGICAL_STRICT.]*/
  219.  
  220. #define C2FLOGICALV(A,I) \
  221.  do {int __i; for(__i=0;__i<I;__i++) A[__i]=C2FLOGICAL(A[__i]); } while (FALSE)
  222. #define F2CLOGICALV(A,I) \
  223.  do {int __i; for(__i=0;__i<I;__i++) A[__i]=F2CLOGICAL(A[__i]); } while (FALSE)
  224.  
  225. #if defined(apolloFortran) || (defined(CRAYFortran) && !defined(_CRAY2))
  226. #ifndef apolloFortran
  227. #define C2FLOGICAL(L) ((L)?(L)|(1<<sizeof(int)*8-1):(L)&~(1<<sizeof(int)*8-1))
  228. #else
  229. #define C2FLOGICAL(L) ((L)?-1:(L)&~(1<<sizeof(int)*8-1)) /* Apollo Exception  */
  230. #endif
  231. #define F2CLOGICAL(L) ((L)<0?(L):0) 
  232. #else
  233. #if defined(IBMR2Fortran) || defined(vmsFortran) || defined(DECFortran)
  234. #define C2FLOGICAL(L) ((L)?(L)|1:(L)&~(int)1)
  235. #define F2CLOGICAL(L) ((L)&1?(L):0)
  236. #else /* all other machines evaluate LOGICALs as C does. */
  237. #define C2FLOGICAL(L) (L)
  238. #define F2CLOGICAL(L) (L)
  239. #ifndef LOGICAL_STRICT
  240. #undef  C2FLOGICALV
  241. #undef  F2CLOGICALV
  242. #define C2FLOGICALV(A,I)
  243. #define F2CLOGICALV(A,I)
  244. #endif  /* LOGICAL_STRICT */
  245. #endif
  246. #endif
  247.  
  248. #ifdef LOGICAL_STRICT
  249. /* Force C2FLOGICAL to generate only the values for either .TRUE. or .FALSE.
  250.    This is only needed if you want to do:
  251.      logical lvariable
  252.      if (lvariable .eq.  .true.) then       ! (1)
  253.    instead of
  254.      if (lvariable .eqv. .true.) then       ! (2)
  255.    - (1) may not even be FORTRAN/77 and that Apollo's f77 and IBM's xlf
  256.    refuse to compile (1), so you are probably well advised to stay away from 
  257.    (1) and from LOGICAL_STRICT.
  258.    - You pay a (slight) performance penalty for using LOGICAL_STRICT. */
  259. #undef C2FLOGICAL
  260. #if defined(apolloFortran) || (defined(CRAYFortran) && !defined(_CRAY2)) || defined(vmsFortran) || defined(DECFortran)
  261. #define C2FLOGICAL(L) ((L)?-1:0) /* These machines use -1/0 for .true./.false.*/
  262. #else
  263. #define C2FLOGICAL(L) ((L)? 1:0) /* All others     use +1/0 for .true./.false.*/
  264. #endif
  265. #endif /* LOGICAL_STRICT */
  266.  
  267. /* Convert a vector of C strings into FORTRAN strings. */
  268. #ifndef __CF__KnR
  269. static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
  270. #else
  271. static char *c2fstrv(      cstr,       fstr,     elem_len,     sizeofcstr)
  272.                      char* cstr; char *fstr; int elem_len; int sizeofcstr;
  273. #endif
  274. { int i,j;
  275. /* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
  276.    Useful size of string must be the same in both languages. */
  277. for (i=0; i<sizeofcstr/elem_len; i++) {
  278.   for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
  279.   cstr += 1+elem_len-j;
  280.   for (; j<elem_len; j++) *fstr++ = ' ';
  281. } return fstr-sizeofcstr+sizeofcstr/elem_len; }
  282.  
  283. /* Convert a vector of FORTRAN strings into C strings. */
  284. #ifndef __CF__KnR
  285. static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
  286. #else
  287. static char *f2cstrv(      fstr,       cstr,     elem_len,     sizeofcstr)
  288.                      char *fstr; char* cstr; int elem_len; int sizeofcstr; 
  289. #endif
  290. { int i,j;
  291. /* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
  292.    Useful size of string must be the same in both languages. */
  293. cstr += sizeofcstr;
  294. fstr += sizeofcstr - sizeofcstr/elem_len;
  295. for (i=0; i<sizeofcstr/elem_len; i++) {
  296.   *--cstr = '\0';
  297.   for (j=1; j<elem_len; j++) *--cstr = *--fstr;
  298. } return cstr; }
  299.  
  300. /* kill the trailing char t's in string s. */
  301. #ifndef __CF__KnR
  302. static char *kill_trailing(char *s, char t)
  303. #else
  304. static char *kill_trailing(      s,      t) char *s; char t;
  305. #endif
  306. {char *e; 
  307. e = s + strlen(s);
  308. if (e>s) {                           /* Need this to handle NULL string.*/
  309.   while (e>s && *--e==t);            /* Don't follow t's past beginning. */
  310.   e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
  311. } return s; }
  312.  
  313. /* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally 
  314. points to the terminating '\0' of s, but may actually point to anywhere in s.
  315. s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
  316. If e<s string s is left unchanged. */ 
  317. #ifndef __CF__KnR
  318. static char *kill_trailingn(char *s, char t, char *e)
  319. #else
  320. static char *kill_trailingn(      s,      t,       e) char *s; char t; char *e;
  321. #endif
  322. { 
  323. if (e==s) *e = '\0';                 /* Kill the string makes sense here.*/
  324. else if (e>s) {                      /* Watch out for neg. length string.*/
  325.   while (e>s && *--e==t);            /* Don't follow t's past beginning. */
  326.   e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
  327. } return s; }
  328.  
  329. /* Note the following assumes that any element which has t's to be chopped off,
  330. does indeed fill the entire element. */
  331. #ifndef __CF__KnR
  332. static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
  333. #else
  334. static char *vkill_trailing(      cstr,     elem_len,     sizeofcstr,      t)
  335.                             char* cstr; int elem_len; int sizeofcstr; char t;
  336. #endif
  337. { int i;
  338. for (i=0; i<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
  339.   kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
  340. return cstr; }
  341.  
  342. #ifdef vmsFortran
  343. typedef struct dsc$descriptor_s fstring;
  344. #define DSC$DESCRIPTOR_A(DIMCT)                                         \
  345. struct {                                                                       \
  346.   unsigned short dsc$w_length;            unsigned char     dsc$b_dtype;           \
  347.   unsigned char     dsc$b_class;                     char    *dsc$a_pointer;           \
  348.            char     dsc$b_scale;            unsigned char     dsc$b_digits;         \
  349.   struct {                                                                     \
  350.     unsigned               : 3;      unsigned dsc$v_fl_binscale : 1;      \
  351.     unsigned dsc$v_fl_redim    : 1;       unsigned dsc$v_fl_column   : 1;      \
  352.     unsigned dsc$v_fl_coeff    : 1;       unsigned dsc$v_fl_bounds   : 1;      \
  353.   } dsc$b_aflags;                                                           \
  354.   unsigned char     dsc$b_dimct;            unsigned long     dsc$l_arsize;           \
  355.            char    *dsc$a_a0;                     long     dsc$l_m [DIMCT];      \
  356.   struct {                                                                     \
  357.     long dsc$l_l;                         long dsc$l_u;                        \
  358.   } dsc$bounds [DIMCT];                                                        \
  359. }
  360. typedef DSC$DESCRIPTOR_A(1) fstringvector;
  361. /*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
  362.   typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
  363. #define initfstr(F,C,ELEMNO,ELEMLEN)                                           \
  364. ( (F).dsc$l_arsize=  ( (F).dsc$w_length                        =(ELEMLEN) )    \
  365.                     *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO)  ),   \
  366.   (F).dsc$a_a0    =  ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length          ,(F))
  367.  
  368. #define F2CSTRVCOPY(C,F)                                                       \
  369.   vkill_trailing(f2cstrv(F->dsc$a_pointer,C,F->dsc$w_length+1,                 \
  370.                          F->dsc$l_m[0]*(F->dsc$w_length+1)),                   \
  371.                  F->dsc$w_length+1,F->dsc$l_m[0]*(F->dsc$w_length+1),' ')
  372. #define C2FSTRVCOPY(C,F) c2fstrv(C,F->dsc$a_pointer,F->dsc$w_length+1,         \
  373.                                  F->dsc$l_m[0]*(F->dsc$w_length+1)    )
  374.  
  375. #else
  376. #define _NUM_ELEMS      -1
  377. #define _NUM_ELEM_ARG   -2
  378. #define NUM_ELEMS(A)    A,_NUM_ELEMS
  379. #define NUM_ELEM_ARG(B) *A/**/B,_NUM_ELEM_ARG
  380. #define TERM_CHARS(A,B) A,B
  381. #ifndef __CF__KnR
  382. static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
  383. #else
  384. static int num_elem(      strv,          elem_len,     term_char,     num_term)
  385.                     char *strv; unsigned elem_len; int term_char; int num_term;
  386. #endif
  387. /* elem_len is the number of characters in each element of strv, the FORTRAN
  388. vector of strings. The last element of the vector must begin with at least
  389. num_term term_char characters, so that this routine can determine how 
  390. many elements are in the vector. */
  391. {
  392. unsigned num,i;
  393. if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG) 
  394.   return term_char;
  395. if (num_term <=0) num_term = elem_len;
  396. for (num=0; ; num++) {
  397.   for (i=0; i<num_term && *strv==term_char; i++,strv++);
  398.   if (i==num_term) break;
  399.   else strv += elem_len-i;
  400. }
  401. return num;
  402. }
  403. #endif
  404. /*-------------------------------------------------------------------------*/
  405.  
  406. /*           UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS       */
  407.  
  408. /* C string TO Fortran Common Block STRing. */
  409. /* DIM is the number of DIMensions of the array in terms of strings, not
  410.    characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
  411. #define C2FCBSTR(CSTR,FSTR,DIM)                                                \
  412.  c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,    \
  413.          sizeof(FSTR)+cfelementsof(FSTR,DIM))
  414.  
  415. /* Fortran Common Block string TO C STRing. */
  416. #define FCB2CSTR(FSTR,CSTR,DIM)                                                \
  417.  vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR,                            \
  418.                         sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                 \
  419.                         sizeof(FSTR)+cfelementsof(FSTR,DIM)),                  \
  420.                 sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                         \
  421.                 sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')
  422.  
  423. #define cfDEREFERENCE0
  424. #define cfDEREFERENCE1 *
  425. #define cfDEREFERENCE2 **
  426. #define cfDEREFERENCE3 ***
  427. #define cfDEREFERENCE4 ****
  428. #define cfDEREFERENCE5 *****
  429. #define cfelementsof(A,D) (sizeof(A)/sizeof(cfDEREFERENCE/**/D(A)))
  430.  
  431. /*-------------------------------------------------------------------------*/
  432.  
  433. /*               UTILITIES FOR C TO CALL FORTRAN SUBROUTINES               */
  434.  
  435. /* Define lookup tables for how to handle the various types of variables.  */
  436.  
  437. #if defined(VAXC) && defined(vms)        /* To avoid %CC-I-PARAMNOTUSED. */
  438. #pragma nostandard
  439. #endif
  440.  
  441. static int __cfztringv[30];       /* => 30 == MAX # of arg.'s C can pass to a */
  442. #define ZTRINGV_NUM(I) I          /*          FORTRAN function.               */
  443. #define ZTRINGV_ARGF(I) __cfztringv[I]
  444. #define ZTRINGV_ARGS(I) B/**/I
  445.  
  446. #define VPPBYTE         VPPINT
  447. #define VPPDOUBLE       VPPINT
  448. #define VPPFLOAT        VPPINT
  449. #define VPPINT(    A,B) int  B = (int)A;   /* For ZSTRINGV_ARGS */
  450. #define VPPLOGICAL(A,B) int *B;         /* Returning LOGICAL in FUNn and SUBn.*/
  451. #define VPPLONG         VPPINT
  452. #define VPPSHORT        VPPINT
  453.  
  454. #define VCF(TN,I)       _INT(3,V,TN,A/**/I,B/**/I)
  455. #define VVCF(TN,AI,BI)  _INT(3,V,TN,AI,BI)
  456. #define VINT(     T,A,B) typeP/**/T/**/VV B = A;
  457. #define VINTV(    T,A,B) typeP/**/T/**/V *B = PP/**/T/**/V A;
  458. #define VINTVV(   T,A,B) typeP/**/T      *B = PP/**/T      A[0];
  459. #define VPINT(    T,A,B) VP/**/T(A,B)
  460. #define VPVOID(   T,A,B)
  461. #define VSIMPLE(  T,A,B)
  462. #ifdef vmsFortran
  463. #define VSTRING(  T,A,B) static struct {fstring f; unsigned clen;} B =         \
  464.                                        {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
  465. #define VPSTRING( T,A,B) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
  466. #define VSTRINGV( T,A,B) static fstringvector B =                              \
  467. {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,0,1,1,1},1,0,NULL,0,{1,0}};
  468. #define VPSTRINGV(T,A,B) static fstringvector B =                              \
  469. {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,0,1,1,1},1,0,NULL,0,{1,0}};
  470. #else
  471. #define VSTRING(  T,A,B) struct {unsigned short clen, flen;} B;
  472. #define VSTRINGV( T,A,B) struct {char *s, *fs; unsigned flen;} B;
  473. #define VPSTRING( T,A,B) int     B;
  474. #define VPSTRINGV(T,A,B) struct {char *fs; unsigned short sizeofA, flen;} B;
  475. #endif
  476. #define VZTRINGV         VSTRINGV
  477. #define VPZTRINGV        VPSTRINGV
  478.  
  479. /* Note that the actions of the A table were performed inside the AA table.
  480.    VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
  481.    right, so we had to split the original table into the current robust two. */
  482. #define ACF(NAME,TN,AI,I)  STR_/**/TN(4,A,NAME,I,AI,B/**/I)
  483. #define ALOGICAL( M,I,A,B) B=C2FLOGICAL(B);
  484. #define APLOGICAL(M,I,A,B) A=C2FLOGICAL(A);
  485. #define ASTRING(  M,I,A,B) CSTRING(A,B,sizeof(A))
  486. #define APSTRING( M,I,A,B) CPSTRING(A,B,sizeof(A))
  487. #ifdef vmsFortran
  488. #define AATRINGV( M,I,A,B, sA,filA,silA)                                       \
  489.  initfstr(B,malloc((sA)-(filA)),(filA),(silA)-1),                              \
  490.           c2fstrv(A[0],B.dsc$a_pointer,(silA),(sA));
  491. #define APATRINGV(M,I,A,B, sA,filA,silA)                                       \
  492.  initfstr(B,A[0],(filA),(silA)-1),c2fstrv(A[0],A[0],(silA),(sA));
  493. #else
  494. #define AATRINGV( M,I,A,B, sA,filA,silA)                                       \
  495.  (B.s=malloc((sA)-(filA)),B.fs=c2fstrv(A[0],B.s,(B.flen=(silA)-1)+1,(sA)));
  496. #define APATRINGV(M,I,A,B, sA,filA,silA)                                       \
  497.  B.fs=c2fstrv(A[0],A[0],(B.flen=(silA)-1)+1,B.sizeofA=(sA));
  498. #endif
  499. #define ASTRINGV( M,I,A,B)                                                     \
  500.   AATRINGV( M,I,A,B,sizeof(A),firstindexlength(A),secondindexlength(A)) 
  501. #define APSTRINGV(M,I,A,B)                                                     \
  502.  APATRINGV( M,I,A,B,sizeof(A),firstindexlength(A),secondindexlength(A)) 
  503. #define AZTRINGV( M,I,A,B) AATRINGV( M,I,A,B,                                  \
  504.                     (M/**/_ELEMS_/**/I)*(( M/**/_ELEMLEN_/**/I)+1),            \
  505.                               (M/**/_ELEMS_/**/I),(M/**/_ELEMLEN_/**/I)+1) 
  506. #define APZTRINGV(M,I,A,B) APATRINGV( M,I,A,B,                                 \
  507.                     (M/**/_ELEMS_/**/I)*(( M/**/_ELEMLEN_/**/I)+1),            \
  508.                               (M/**/_ELEMS_/**/I),(M/**/_ELEMLEN_/**/I)+1) 
  509.  
  510. #define AAPPBYTE(   A,B) &A
  511. #define AAPPDOUBLE( A,B) &A
  512. #define AAPPFLOAT(  A,B) PPFLOATVV &A
  513. #define AAPPINT(    A,B) &A
  514. #define AAPPLOGICAL(A,B) B= &A         /* B used to keep a common W table. */
  515. #define AAPPLONG(   A,B) &A
  516. #define AAPPSHORT(  A,B) &A
  517.  
  518. #define AACF(TN,AI,I,C) _SEP_(TN,C,COMMA) _INT(3,AA,TN,AI,B/**/I)
  519. #define AAINT(     T,A,B) &B
  520. #define AAINTV(    T,A,B)  B
  521. #define AAINTVV(   T,A,B)  B
  522. #define AAPINT(    T,A,B) AAP/**/T(A,B)
  523. #define AAPVOID(   T,A,B) (void *) A
  524. #define AASTRING(  T,A,B) CCSTRING(T,A,B)
  525. #define AAPSTRING( T,A,B) CCPSTRING(T,A,B)
  526. #ifdef vmsFortran
  527. #define AASTRINGV( T,A,B) &B
  528. #else
  529. #ifdef CRAYFortran
  530. #define AASTRINGV( T,A,B) _cptofcd(B.fs,B.flen)
  531. #else
  532. #define AASTRINGV( T,A,B) B.fs
  533. #endif
  534. #endif
  535. #define AAPSTRINGV      AASTRINGV
  536. #define AAZTRINGV       AASTRINGV
  537. #define AAPZTRINGV      AASTRINGV
  538.  
  539. #if defined(vmsFortran) || defined(CRAYFortran)
  540. #define JCF(TN,I)
  541. #else
  542. #define JCF(TN,I)    STR_/**/TN(1,J,B/**/I, 0,0,0)
  543. #define JLOGICAL( B)
  544. #define JPLOGICAL(B)
  545. #define JSTRING(  B) ,B.flen
  546. #define JPSTRING( B) ,B
  547. #define JSTRINGV     JSTRING
  548. #define JPSTRINGV    JSTRING
  549. #define JZTRINGV     JSTRING
  550. #define JPZTRINGV    JSTRING
  551. #endif
  552.  
  553. #define WCF(TN,AN,I)   STR_/**/TN(2,W,AN,B/**/I, 0,0)
  554. #define WLOGICAL( A,B)
  555. #define WPLOGICAL(A,B) *B=F2CLOGICAL(*B);
  556. #define WSTRING(  A,B) (A[B.clen]!='\0'?A[B.clen]='\0':0); /* A?="constnt"*/
  557. #define WPSTRING( A,B) kill_trailing(A,' ');
  558. #ifdef vmsFortran
  559. #define WSTRINGV( A,B) free(B.dsc$a_pointer);
  560. #define WPSTRINGV(A,B)                                                         \
  561.   vkill_trailing(f2cstrv((char*)A, (char*)A,                                   \
  562.                            B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]),     \
  563.                    B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
  564. #else
  565. #define WSTRINGV( A,B) free(B.s);
  566. #define WPSTRINGV(A,B) vkill_trailing(                                         \
  567.          f2cstrv((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
  568. #endif
  569. #define WZTRINGV           WSTRINGV
  570. #define WPZTRINGV          WPSTRINGV
  571.  
  572. #define   nCF(TN,  C)  _SEP_(TN,C,COMMA) _INT(1,N,TN,0,0)
  573. #define   NCF(TN,I,C)  _SEP_(TN,C,COMMA) _INT(1,N,TN,0,0) _SEP_(TN,1,I)
  574. #define  NNCF          UUCF
  575. #define NNNCF(TN,I,C)  _SEP_(TN,C,COLON) _INT(1,N,TN,0,0) _SEP_(TN,1,I)
  576. #define NINT(     T) typeP/**/T/**/VV *
  577. #define NINTV(    T) typeP/**/T/**/V  *
  578. #define NINTVV(   T) typeP/**/T       *
  579. #define NPINT(    T)  type/**/T/**/VV *
  580. #define NPVOID(   T) void *
  581. #ifdef vmsFortran
  582. #define NSTRING(  T) fstring *
  583. #define NSTRINGV( T) fstringvector *
  584. #else
  585. #ifdef CRAYFortran
  586. #define NSTRING(  T) _fcd
  587. #define NSTRINGV( T) _fcd
  588. #else
  589. #define NSTRING(  T) char *
  590. #define NSTRINGV( T) char *
  591. #endif
  592. #endif
  593. #define NPSTRING( T) NSTRING(T)   /* CRAY insists on arg.'s here. */
  594. #define NPSTRINGV(T) NSTRINGV(T)
  595. #define NZTRINGV( T) NSTRINGV(T)
  596. #define NPZTRINGV(T) NPSTRINGV(T)
  597.  
  598. /* Note: To avoid compiler warnings, null #define PROTOCCALLSFSUB14/20 after 
  599.    #include-ing cfortran.h if calling the FORTRAN wrapper within the same 
  600.    source code where the wrapper is created. */
  601. #ifndef __CF__KnR
  602. #define PROTOCCALLSFSUB0(UN,LN)          extern void CFC_(UN,LN)();
  603. #define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)     \
  604.  extern void CFC_(UN,LN)(nCF(T1,0) nCF(T2,1) nCF(T3,1) nCF(T4,1) nCF(T5,1)     \
  605.      nCF(T6,1) nCF(T7,1) nCF(T8,1) nCF(T9,1) nCF(TA,1) nCF(TB,1) nCF(TC,1)     \
  606.      nCF(TD,1) nCF(TE,1) ,...);
  607. #define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
  608.  extern void CFC_(UN,LN)(nCF(T1,0) nCF(T2,1) nCF(T3,1) nCF(T4,1) nCF(T5,1)     \
  609.      nCF(T6,1) nCF(T7,1) nCF(T8,1) nCF(T9,1) nCF(TA,1) nCF(TB,1) nCF(TC,1)     \
  610.      nCF(TD,1) nCF(TE,1) nCF(TF,1) nCF(TG,1) nCF(TH,1) nCF(TI,1) nCF(TJ,1) nCF(TK,1),...);
  611. #else
  612. #define PROTOCCALLSFSUB0( UN,LN)
  613. #define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
  614. #define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
  615. #endif
  616.  
  617. #if defined(VAXC) && defined(vms)        /* Have avoid %CC-I-PARAMNOTUSED. */
  618. #pragma standard
  619. #endif
  620.  
  621. /* do{...}while(FALSE) allows if(a==b) FORT(); else BORT(); */
  622.  
  623. #define CCALLSFSUB0(UN,LN) \
  624.  do{PROTOCCALLSFSUB0(UN,LN) CFC_(UN,LN)();}while(FALSE)
  625.  
  626. #define CCALLSFSUB1( UN,LN,T1,                        A1)         \
  627.         CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
  628. #define CCALLSFSUB2( UN,LN,T1,T2,                     A1,A2)      \
  629.         CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
  630. #define CCALLSFSUB3( UN,LN,T1,T2,T3,                  A1,A2,A3)   \
  631.         CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
  632. #define CCALLSFSUB4( UN,LN,T1,T2,T3,T4,               A1,A2,A3,A4)\
  633.         CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
  634. #define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5,            A1,A2,A3,A4,A5)          \
  635.         CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
  636. #define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6,         A1,A2,A3,A4,A5,A6)       \
  637.         CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
  638. #define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7,      A1,A2,A3,A4,A5,A6,A7)    \
  639.         CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
  640. #define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,   A1,A2,A3,A4,A5,A6,A7,A8) \
  641.         CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
  642. #define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
  643.         CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
  644. #define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
  645.         CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
  646. #define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
  647.         CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
  648. #define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
  649.         CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
  650. #define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
  651.         CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
  652.  
  653. #define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
  654. do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5)  \
  655.    VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,BA)  \
  656.    VVCF(TB,AB,BB) VVCF(TC,AC,BC) VVCF(TD,AD,BD) VVCF(TE,AE,BE)                 \
  657.    PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)          \
  658.    ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3)                             \
  659.    ACF(LN,T4,A4,4) ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7)             \
  660.    ACF(LN,T8,A8,8) ACF(LN,T9,A9,9) ACF(LN,TA,AA,A) ACF(LN,TB,AB,B)             \
  661.    ACF(LN,TC,AC,C) ACF(LN,TD,AD,D) ACF(LN,TE,AE,E)                             \
  662.    CFC_(UN,LN)(AACF(T1,A1,1,0) AACF(T2,A2,2,1) AACF(T3,A3,3,1)                 \
  663.                AACF(T4,A4,4,1) AACF(T5,A5,5,1) AACF(T6,A6,6,1) AACF(T7,A7,7,1) \
  664.                AACF(T8,A8,8,1) AACF(T9,A9,9,1) AACF(TA,AA,A,1) AACF(TB,AB,B,1) \
  665.                AACF(TC,AC,C,1) AACF(TD,AD,D,1) AACF(TE,AE,E,1)                 \
  666.       JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5) JCF(T6,6) JCF(T7,7)    \
  667.       JCF(T8,8) JCF(T9,9) JCF(TA,A) JCF(TB,B) JCF(TC,C) JCF(TD,D) JCF(TE,E)  );\
  668.    WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5)            \
  669.    WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,A)            \
  670.    WCF(TB,AB,B) WCF(TC,AC,C) WCF(TD,AD,D) WCF(TE,AE,E)             }while(FALSE)
  671.  
  672. /* Apollo 6.7, CRAY, Sun, VAX/Ultrix vcc/cc and HP can't hack more than 31 arg's */
  673. #if !(defined(VAXUltrix)&&!defined(__GNUC__)) && !defined(__CF__APOLLO67) && !defined(sun) && !defined(__hp9000s300) && !defined(_CRAY)
  674. #define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\
  675.         CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0)
  676. #define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\
  677.         CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0)
  678. #define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\
  679.         CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0)
  680. #define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\
  681.         CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0)
  682. #define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\
  683.         CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0)
  684.  
  685. /* PROTOCCALLSFSUB20 is commented out, because it chokes the VAX VMS compiler.
  686.    It isn't required since we so far only pass pointers and integers to 
  687.    FORTRAN routines and these arg.'s aren't promoted to anything else.        */
  688.  
  689. #define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
  690.         TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
  691. do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5)  \
  692.    VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,BA)  \
  693.    VVCF(TB,AB,BB) VVCF(TC,AC,BC) VVCF(TD,AD,BD) VVCF(TE,AE,BE) VVCF(TF,AF,BF)  \
  694.    VVCF(TG,AG,BG) VVCF(TH,AH,BH) VVCF(TI,AI,BI) VVCF(TJ,AJ,BJ) VVCF(TK,AK,BK)  \
  695. /*   PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)*/\
  696.    ACF(LN,T1,A1,1) ACF(LN,T2,A2,2) ACF(LN,T3,A3,3) ACF(LN,T4,A4,4)             \
  697.    ACF(LN,T5,A5,5) ACF(LN,T6,A6,6) ACF(LN,T7,A7,7) ACF(LN,T8,A8,8)             \
  698.    ACF(LN,T9,A9,9) ACF(LN,TA,AA,A) ACF(LN,TB,AB,B) ACF(LN,TC,AC,C)             \
  699.    ACF(LN,TD,AD,D) ACF(LN,TE,AE,E) ACF(LN,TF,AF,F) ACF(LN,TG,AG,G)             \
  700.    ACF(LN,TH,AH,H) ACF(LN,TI,AI,I) ACF(LN,TJ,AJ,J) ACF(LN,TK,AK,K)             \
  701.    CFC_(UN,LN)(AACF(T1,A1,1,0) AACF(T2,A2,2,1) AACF(T3,A3,3,1) AACF(T4,A4,4,1) \
  702.                AACF(T5,A5,5,1) AACF(T6,A6,6,1) AACF(T7,A7,7,1) AACF(T8,A8,8,1) \
  703.                AACF(T9,A9,9,1) AACF(TA,AA,A,1) AACF(TB,AB,B,1) AACF(TC,AC,C,1) \
  704.                AACF(TD,AD,D,1) AACF(TE,AE,E,1) AACF(TF,AF,F,1) AACF(TG,AG,G,1) \
  705.                AACF(TH,AH,H,1) AACF(TI,AI,I,1) AACF(TJ,AJ,J,1) AACF(TK,AK,K,1) \
  706.       JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5) JCF(T6,6) JCF(T7,7)    \
  707.       JCF(T8,8) JCF(T9,9) JCF(TA,A) JCF(TB,B) JCF(TC,C) JCF(TD,D) JCF(TE,E)    \
  708.       JCF(TF,F) JCF(TG,G) JCF(TH,H) JCF(TI,I) JCF(TJ,J) JCF(TK,K)          );  \
  709.  WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5) WCF(T6,A6,6) \
  710.  WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,A) WCF(TB,AB,B) WCF(TC,AC,C) \
  711.  WCF(TD,AD,D) WCF(TE,AE,E) WCF(TF,AF,F) WCF(TG,AG,G) WCF(TH,AH,H) WCF(TI,AI,I) \
  712.  WCF(TJ,AJ,J) WCF(TK,AK,K) }while(FALSE)
  713. #endif         /* Apollo 6.7, CRAY, Sun and HP can't hack more than 31 arg.'s */
  714.  
  715. /*-------------------------------------------------------------------------*/
  716.  
  717. /*               UTILITIES FOR C TO CALL FORTRAN FUNCTIONS                 */
  718.  
  719. /*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN
  720.   function is called. Therefore, especially for creator's of C header files
  721.   for large FORTRAN libraries which include many functions, to reduce
  722.   compile time and object code size, it may be desirable to create
  723.   preprocessor directives to allow users to create code for only those
  724.   functions which they use.                                                */
  725.  
  726. /* The following defines the maximum length string that a function can return.
  727.    Of course it may be undefine-d and re-define-d before individual
  728.    PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived
  729.    from the individual machines' limits.                                      */
  730. #define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE
  731.  
  732. /* The following defines a character used by CFORTRAN.H to flag the end of a
  733.    string coming out of a FORTRAN routine.                                 */
  734. #define CFORTRAN_NON_CHAR 0x7F
  735.  
  736. #if defined(VAXC) && defined(vms)        /* To avoid %CC-I-PARAMNOTUSED. */
  737. #pragma nostandard
  738. #endif
  739.  
  740. #define _SEP_(TN,C,COMMA) __SEP_/**/C(TN,COMMA)
  741. #define __SEP_0(TN,COMMA)  
  742. #define __SEP_1(TN,COMMA)  _INT(2,SEP_,TN,COMMA,0)
  743. #define SEP_INT(     T,B) A/**/B
  744. #define SEP_INTV     SEP_INT
  745. #define SEP_INTVV    SEP_INT
  746. #define SEP_PINT     SEP_INT
  747. #define SEP_PVOID    SEP_INT
  748. #define SEP_SIMPLE   SEP_INT
  749. #define SEP_VOID     SEP_INT      /* Need for FORTRAN calls to C subroutines. */
  750. #define SEP_STRING   SEP_INT
  751. #define SEP_STRINGV  SEP_INT
  752. #define SEP_PSTRING  SEP_INT
  753. #define SEP_PSTRINGV SEP_INT
  754. #define SEP_ZTRINGV  SEP_INT
  755. #define SEP_PZTRINGV SEP_INT
  756.                          
  757. #if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE)
  758. #if defined(VAXC) && defined(vms)
  759. #define INTEGER_BYTE            char        /* VAXC barfs on 'signed char' */
  760. #else
  761. #define INTEGER_BYTE     signed char        /* default */
  762. #endif
  763. #else
  764. #define INTEGER_BYTE   unsigned char
  765. #endif
  766. #define typePBYTEVV    INTEGER_BYTE
  767. #define typePDOUBLEVV  DOUBLE_PRECISION 
  768. #define typePFLOATVV   float
  769. #define typePINTVV     int
  770. #define typePLOGICALVV int
  771. #define typePLONGVV    long
  772. #define typePSHORTVV   short
  773.  
  774. #define CFARGS0(A,T,W,X,Y,Z) A/**/T
  775. #define CFARGS1(A,T,W,X,Y,Z) A/**/T(W)
  776. #define CFARGS2(A,T,W,X,Y,Z) A/**/T(W,X)
  777. #define CFARGS3(A,T,W,X,Y,Z) A/**/T(W,X,Y)
  778. #define CFARGS4(A,T,W,X,Y,Z) A/**/T(W,X,Y,Z)
  779.  
  780. #define _INT(N,T,I,Y,Z) INT_/**/I(N,T,I,Y,Z)
  781. #define INT_BYTE     INT_DOUBLE
  782. #define INT_DOUBLE(  N,A,B,Y,Z) CFARGS/**/N(A,INT,B,Y,Z,0)
  783. #define INT_FLOAT    INT_DOUBLE
  784. #define INT_INT      INT_DOUBLE
  785. #define INT_LOGICAL  INT_DOUBLE
  786. #define INT_LONG     INT_DOUBLE
  787. #define INT_SHORT    INT_DOUBLE
  788. #define INT_BYTEV    INT_DOUBLEV
  789. #define INT_DOUBLEV( N,A,B,Y,Z) CFARGS/**/N(A,INTV,B,Y,Z,0)
  790. #define INT_FLOATV   INT_DOUBLEV
  791. #define INT_INTV     INT_DOUBLEV
  792. #define INT_LOGICALV INT_DOUBLEV
  793. #define INT_LONGV    INT_DOUBLEV
  794. #define INT_SHORTV   INT_DOUBLEV
  795. #define INT_BYTEVV   INT_DOUBLEVV
  796. #define INT_DOUBLEVV(N,A,B,Y,Z) CFARGS/**/N(A,INTVV,B,Y,Z,0)
  797. #define INT_FLOATVV  INT_DOUBLEVV
  798. #define INT_INTVV    INT_DOUBLEVV
  799. #define INT_LOGICALVV INT_DOUBLEVV
  800. #define INT_LONGVV   INT_DOUBLEVV
  801. #define INT_SHORTVV  INT_DOUBLEVV
  802. #define INT_PBYTE    INT_PDOUBLE
  803. #define INT_PDOUBLE( N,A,B,Y,Z) CFARGS/**/N(A,PINT,B,Y,Z,0)
  804. #define INT_PFLOAT   INT_PDOUBLE
  805. #define INT_PINT     INT_PDOUBLE
  806. #define INT_PLOGICAL INT_PDOUBLE
  807. #define INT_PLONG    INT_PDOUBLE
  808. #define INT_PSHORT   INT_PDOUBLE
  809. #define INT_PVOID(   N,A,B,Y,Z) CFARGS/**/N(A,B,B,Y,Z,0)
  810. /*CRAY coughs on the first, i.e. the usual trouble of not being able to
  811.   define macros to macros with arguments. */
  812. /*#define INT_SIMPLE   INT_PVOID*/
  813. #define INT_SIMPLE(  N,A,B,Y,Z)   INT_PVOID(N,A,B,Y,Z)
  814. #define INT_VOID     INT_PVOID
  815. #define INT_STRING   INT_PVOID
  816. #define INT_STRINGV  INT_PVOID
  817. #define INT_PSTRING  INT_PVOID
  818. #define INT_PSTRINGV INT_PVOID
  819. #define INT_ZTRINGV  INT_PVOID
  820. #define INT_PZTRINGV INT_PVOID
  821. #define INT_CF_0(    N,A,B,Y,Z)
  822.                          
  823. #define   UCF(TN,I,C)  _SEP_(TN,C,COMMA) _INT(2,U,TN,A/**/I,0)
  824. #define  UUCF(TN,I,C)  _SEP_(TN,C,COMMA) _SEP_(TN,1,I) 
  825. #define UUUCF(TN,I,C)  _SEP_(TN,C,COLON) _INT(2,U,TN,A/**/I,0)
  826. #define UINT(     T,A) typeP/**/T/**/VV  A
  827. #define UINTV(    T,A) typeP/**/T/**/V  *A
  828. #define UINTVV(   T,A) typeP/**/T       *A
  829. #define UPINT(    T,A)  type/**/T/**/VV *A
  830. #define UPVOID(   T,A) void *A 
  831. #define UVOID(    T,A) void *A          /*Needed for FORTRAN/C subroutines. */
  832. #define USTRING(  T,A) char *A 
  833. #define USTRINGV( T,A) char *A
  834. #define UPSTRING( T,A) char *A
  835. #define UPSTRINGV(T,A) char *A
  836. #define UZTRINGV( T,A) char *A
  837. #define UPZTRINGV(T,A) char *A
  838.  
  839. /* Only Sun breaks U into U and PU. */
  840. #define PUBYTE(      A) INTEGER_BYTE     A
  841. #define PUDOUBLE(    A) DOUBLE_PRECISION A
  842. #ifndef sunFortran
  843. #define PUFLOAT(     A) float   A
  844. #else
  845. #define PUFLOAT(     A) FLOATFUNCTIONTYPE   A
  846. #endif
  847. #define PUINT(       A) int     A
  848. #define PULOGICAL(   A) int     A
  849. #define PULONG(      A) long    A
  850. #define PUSHORT(     A) short   A
  851. #define PUSTRING(    A) char   *A 
  852. #define PUVOID(      A) void    A
  853.  
  854. #define EBYTE          INTEGER_BYTE     A0;
  855. #define EDOUBLE        DOUBLE_PRECISION A0;
  856. #ifndef sunFortran
  857. #define EFLOAT         float  A0;
  858. #else
  859. #define EFLOAT         float AA0;   FLOATFUNCTIONTYPE A0;
  860. #endif
  861. #define EINT           int    A0;
  862. #define ELOGICAL       int    A0;
  863. #define ELONG          long   A0;
  864. #define ESHORT         short  A0;
  865. #define EVOID
  866. #ifdef vmsFortran
  867. #define ESTRING        static char AA0[MAX_LEN_FORTRAN_FUNCTION_STRING+1];     \
  868.                        static fstring A0 =                                     \
  869.              {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\
  870.                memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
  871.                                     *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
  872. #else
  873. #ifdef CRAYFortran
  874. #define ESTRING        static char AA0[MAX_LEN_FORTRAN_FUNCTION_STRING+1];     \
  875.                    static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\
  876.                 memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
  877.                             A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING);
  878. #else
  879. #define ESTRING        static char A0[MAX_LEN_FORTRAN_FUNCTION_STRING+1];      \
  880.                        memset(A0, CFORTRAN_NON_CHAR,                           \
  881.                               MAX_LEN_FORTRAN_FUNCTION_STRING);                \
  882.                        *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
  883. #endif
  884. #endif
  885. /* ESTRING must use static char. array which is guaranteed to exist after
  886.    function returns.                                                     */
  887.  
  888. /* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
  889.        ii)That the following create an unmatched bracket, i.e. '(', which
  890.           must of course be matched in the call.
  891.        iii)Commas must be handled very carefully                         */
  892. #define GZINT(    T,UN,LN) A0=CFC_(UN,LN)(
  893. #define GZVOID(   T,UN,LN)    CFC_(UN,LN)(
  894. #ifdef vmsFortran
  895. #define GZSTRING( T,UN,LN)    CFC_(UN,LN)(&A0
  896. #else
  897. #ifdef CRAYFortran
  898. #define GZSTRING( T,UN,LN)    CFC_(UN,LN)( A0
  899. #else
  900. #define GZSTRING( T,UN,LN)    CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING
  901. #endif
  902. #endif
  903.  
  904. #define GINT               GZINT
  905. #define GVOID              GZVOID
  906. #define GSTRING(  T,UN,LN) GZSTRING(T,UN,LN),
  907.  
  908. #define PPBYTEVV
  909. #define PPINTVV     /* These complement PPFLOATVV. */
  910. #define PPDOUBLEVV
  911. #define PPLOGICALVV
  912. #define PPLONGVV
  913. #define PPSHORTVV
  914.  
  915. #define BCF(TN,AN,C)   _SEP_(TN,C,COMMA) _INT(2,B,TN,AN,0)
  916. #define BINT(     T,A) (typeP/**/T/**/VV) A
  917. #define BINTV(    T,A)           A
  918. #define BINTVV(   T,A)          (A)[0]
  919. #define BPINT(    T,A) P/**/T/**/VV  &A
  920. #define BSTRING(  T,A) (char *)  A
  921. #define BSTRINGV( T,A) (char *)  A
  922. #define BPSTRING( T,A) (char *)  A
  923. #define BPSTRINGV(T,A) (char *)  A
  924. #define BPVOID(   T,A) (void *)  A
  925. #define BZTRINGV( T,A) (char *)  A
  926. #define BPZTRINGV(T,A) (char *)  A
  927.                                                                   
  928. #define ZCF(TN,N,AN)   _INT(3,Z,TN,N,AN)
  929. #define ZINT(     T,I,A) (__cfztringv[I]=(int)A),
  930. #define ZPINT            ZINT
  931. #define ZINTV(    T,I,A)
  932. #define ZINTVV(   T,I,A)
  933. #define ZSTRING(  T,I,A)
  934. #define ZSTRINGV( T,I,A)
  935. #define ZPSTRING( T,I,A)
  936. #define ZPSTRINGV(T,I,A)
  937. #define ZPVOID(   T,I,A)
  938. #define ZSIMPLE(  T,I,A)
  939. #define ZZTRINGV( T,I,A)
  940. #define ZPZTRINGV(T,I,A)
  941.  
  942. #define SCF(TN,NAME,I,A) STR_/**/TN(3,S,NAME,I,A,0)
  943. #define SLOGICAL( M,I,A)
  944. #define SPLOGICAL(M,I,A)
  945. #define SSTRING(  M,I,A) ,sizeof(A)
  946. #define SSTRINGV( M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A)               \
  947.                              +secondindexlength(A))
  948. #define SPSTRING( M,I,A) ,sizeof(A)
  949. #define SPSTRINGV          SSTRINGV
  950. #define SZTRINGV( M,I,A) ,( (unsigned)0xFFFF*M/**/_ELEMS_/**/I                 \
  951.                              +M/**/_ELEMLEN_/**/I+1)
  952. #define SPZTRINGV        SZTRINGV
  953.  
  954. #define   HCF(TN,I)      STR_/**/TN(3,H,COMMA, H,C/**/I,0)
  955. #define  HHCF(TN,I)      STR_/**/TN(3,H,COMMA,HH,C/**/I,0)
  956. #define HHHCF(TN,I)      STR_/**/TN(3,H,COLON, H,C/**/I,0)
  957. #define  H_CF_SPECIAL    unsigned
  958. #define HH_CF_SPECIAL
  959. #define HLOGICAL( S,U,B)
  960. #define HPLOGICAL(S,U,B)
  961. #define HSTRING(  S,U,B) A/**/S U/**/_CF_SPECIAL B
  962. #define HSTRINGV         HSTRING    
  963. #define HPSTRING         HSTRING
  964. #define HPSTRINGV        HSTRING
  965. #define HZTRINGV         HSTRING
  966. #define HPZTRINGV        HSTRING
  967.  
  968. #define STR_BYTE(    N,T,A,B,C,D)
  969. #define STR_DOUBLE(  N,T,A,B,C,D)            /* Can't add spaces inside       */
  970. #define STR_FLOAT(   N,T,A,B,C,D)            /* expansion since it screws up  */
  971. #define STR_INT(     N,T,A,B,C,D)            /* macro catenation kludge.      */
  972. #define STR_LOGICAL( N,T,A,B,C,D) CFARGS/**/N(T,LOGICAL,A,B,C,D)
  973. #define STR_LONG(    N,T,A,B,C,D)
  974. #define STR_SHORT(   N,T,A,B,C,D)
  975. #define STR_BYTEV(   N,T,A,B,C,D)
  976. #define STR_DOUBLEV( N,T,A,B,C,D)
  977. #define STR_FLOATV(  N,T,A,B,C,D)
  978. #define STR_INTV(    N,T,A,B,C,D)
  979. #define STR_LOGICALV(N,T,A,B,C,D)
  980. #define STR_LONGV(   N,T,A,B,C,D)
  981. #define STR_SHORTV(  N,T,A,B,C,D)
  982. #define STR_BYTEVV(  N,T,A,B,C,D)
  983. #define STR_DOUBLEVV(N,T,A,B,C,D)
  984. #define STR_FLOATVV( N,T,A,B,C,D)
  985. #define STR_INTVV(   N,T,A,B,C,D)
  986. #define STR_LOGICALVV(N,T,A,B,C,D)
  987. #define STR_LONGVV(  N,T,A,B,C,D)
  988. #define STR_SHORTVV( N,T,A,B,C,D)
  989. #define STR_PBYTE(   N,T,A,B,C,D)
  990. #define STR_PDOUBLE( N,T,A,B,C,D)
  991. #define STR_PFLOAT(  N,T,A,B,C,D)
  992. #define STR_PINT(    N,T,A,B,C,D)
  993. #define STR_PLOGICAL(N,T,A,B,C,D) CFARGS/**/N(T,PLOGICAL,A,B,C,D)
  994. #define STR_PLONG(   N,T,A,B,C,D)
  995. #define STR_PSHORT(  N,T,A,B,C,D)
  996. #define STR_STRING(  N,T,A,B,C,D) CFARGS/**/N(T,STRING,A,B,C,D)
  997. #define STR_PSTRING( N,T,A,B,C,D) CFARGS/**/N(T,PSTRING,A,B,C,D)
  998. #define STR_STRINGV( N,T,A,B,C,D) CFARGS/**/N(T,STRINGV,A,B,C,D)
  999. #define STR_PSTRINGV(N,T,A,B,C,D) CFARGS/**/N(T,PSTRINGV,A,B,C,D)
  1000. #define STR_PVOID(   N,T,A,B,C,D)
  1001. #define STR_SIMPLE(  N,T,A,B,C,D)
  1002. #define STR_ZTRINGV( N,T,A,B,C,D) CFARGS/**/N(T,ZTRINGV,A,B,C,D)
  1003. #define STR_PZTRINGV(N,T,A,B,C,D) CFARGS/**/N(T,PZTRINGV,A,B,C,D)
  1004. #define STR_CF_0(    N,T,A,B,C,D)               
  1005.  
  1006. /* See ACF table comments, which explain why CCF was split into two. */
  1007. #define CCF(TN,I)          STR_/**/TN(3,C,A/**/I,B/**/I,C/**/I,0)
  1008. #define CLOGICAL( A,B,C)  A=C2FLOGICAL( A);
  1009. #define CPLOGICAL(A,B,C) *A=C2FLOGICAL(*A);
  1010. #ifdef vmsFortran
  1011. #define CSTRING(  A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A,                \
  1012.                     C==sizeof(char*)||C==B.clen+1?B.f.dsc$w_length=B.clen:     \
  1013.           (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0'));
  1014. #define CSTRINGV( A,B,C) (                                                     \
  1015.           initfstr(B, malloc((C/0xFFFF)*(C%0xFFFF-1)), C/0xFFFF, C%0xFFFF-1),  \
  1016.           c2fstrv(A,B.dsc$a_pointer,C%0xFFFF,(C/0xFFFF)*(C%0xFFFF)) );
  1017. #define CPSTRING( A,B,C) (B.dsc$w_length=strlen(A),B.dsc$a_pointer=A,          \
  1018.         C==sizeof(char*)?0:(memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), \
  1019.                              A[B.dsc$w_length=C-1]='\0'));
  1020. #define CPSTRINGV(A,B,C)  (initfstr(B, A, C/0xFFFF, C%0xFFFF-1),               \
  1021.                              c2fstrv(A,A,C%0xFFFF,(C/0xFFFF)*(C%0xFFFF)) );
  1022. #else
  1023. #ifdef CRAYFortran
  1024. #define CSTRING(  A,B,C) (B.clen=strlen(A),                                    \
  1025.                           C==sizeof(char*)||C==B.clen+1?B.flen=B.clen:         \
  1026.                         (memset((A)+B.clen,' ',C-B.clen-1),A[B.flen=C-1]='\0'));
  1027. #define CSTRINGV( A,B,C) (B.s=malloc((C/0xFFFF)*(C%0xFFFF-1)),                 \
  1028.                     c2fstrv(A,B.s,(B.flen=C%0xFFFF-1)+1,(C/0xFFFF)*(C%0xFFFF)));
  1029. #define CPSTRING( A,B,C) (B=strlen(A), C==sizeof(char*)?0:                     \
  1030.                             (memset((A)+B,' ',C-B-1),A[B=C-1]='\0'));
  1031. #define CPSTRINGV(A,B,C) c2fstrv(A,A,(B.flen=C%0xFFFF-1)+1,                    \
  1032.                                    B.sizeofA=(C/0xFFFF)*(C%0xFFFF));
  1033. #else
  1034. #define CSTRING(  A,B,C) (B.clen=strlen(A),                                    \
  1035.                             C==sizeof(char*)||C==B.clen+1?B.flen=B.clen:       \
  1036.                         (memset((A)+B.clen,' ',C-B.clen-1),A[B.flen=C-1]='\0'));
  1037. #define CSTRINGV( A,B,C) (B.s=malloc((C/0xFFFF)*(C%0xFFFF-1)),                 \
  1038.                B.fs=c2fstrv(A,B.s,(B.flen=C%0xFFFF-1)+1,(C/0xFFFF)*(C%0xFFFF)));
  1039. #define CPSTRING( A,B,C) (B=strlen(A), C==sizeof(char*)?0:                     \
  1040.                             (memset((A)+B,' ',C-B-1),A[B=C-1]='\0'));
  1041. #define CPSTRINGV(A,B,C) B.fs=c2fstrv(A,A,(B.flen=C%0xFFFF-1)+1,               \
  1042.                                         B.sizeofA=(C/0xFFFF)*(C%0xFFFF));
  1043. #endif
  1044. #endif
  1045. #define CZTRINGV         CSTRINGV
  1046. #define CPZTRINGV        CPSTRINGV
  1047.  
  1048. #define CCCBYTE(    A,B) &A
  1049. #define CCCDOUBLE(  A,B) &A
  1050. #if !defined(__CF__KnR)
  1051. #define CCCFLOAT(   A,B) &A
  1052.                             /* Although the VAX doesn't, at least the         */
  1053. #else                       /* HP and K&R mips promote float arg.'s of        */
  1054. #define CCCFLOAT(   A,B) &B  /* unprototyped functions to double. So we can't  */
  1055. #endif                      /* use A here to pass the argument to FORTRAN.    */
  1056. #define CCCINT(     A,B) &A
  1057. #define CCCLOGICAL( A,B) &A
  1058. #define CCCLONG(    A,B) &A
  1059. #define CCCSHORT(   A,B) &A
  1060. #define CCCPBYTE(   A,B)  A
  1061. #define CCCPDOUBLE( A,B)  A
  1062. #define CCCPFLOAT(  A,B)  A
  1063. #define CCCPINT(    A,B)  A
  1064. #define CCCPLOGICAL(A,B)  B=A       /* B used to keep a common W table. */
  1065. #define CCCPLONG(   A,B)  A
  1066. #define CCCPSHORT(  A,B)  A
  1067.  
  1068. #define CCCF(TN,I,M)    _SEP_(TN,M,COMMA) _INT(3,CC,TN,A/**/I,B/**/I)
  1069. #define CCINT(     T,A,B) CCC/**/T(A,B) 
  1070. #define CCINTV(    T,A,B)  A
  1071. #define CCINTVV(   T,A,B)  A
  1072. #define CCPINT(    T,A,B) CCC/**/T(A,B) 
  1073. #define CCPVOID(   T,A,B)  A
  1074. #define CCSIMPLE(  T,A,B)  A
  1075. #ifdef vmsFortran
  1076. #define CCSTRING(  T,A,B) &B.f
  1077. #define CCSTRINGV( T,A,B) &B
  1078. #define CCPSTRING( T,A,B) &B
  1079. #define CCPSTRINGV(T,A,B) &B
  1080. #else
  1081. #ifdef CRAYFortran
  1082. #define CCSTRING(  T,A,B) _cptofcd(A,B.flen)
  1083. #define CCSTRINGV( T,A,B) _cptofcd(B.s,B.flen)
  1084. #define CCPSTRING( T,A,B) _cptofcd(A,B)
  1085. #define CCPSTRINGV(T,A,B) _cptofcd(A,B.flen)
  1086. #else
  1087. #define CCSTRING(  T,A,B)  A
  1088. #define CCSTRINGV( T,A,B)  B.fs
  1089. #define CCPSTRING( T,A,B)  A
  1090. #define CCPSTRINGV(T,A,B)  B.fs
  1091. #endif
  1092. #endif
  1093. #define CCZTRINGV       CCSTRINGV
  1094. #define CCPZTRINGV      CCPSTRINGV
  1095.  
  1096. #define XBYTE          return A0;
  1097. #define XDOUBLE        return A0;
  1098. #ifndef sunFortran
  1099. #define XFLOAT         return A0;
  1100. #else
  1101. #define XFLOAT         ASSIGNFLOAT(AA0,A0); return AA0;
  1102. #endif
  1103. #define XINT           return A0;
  1104. #define XLOGICAL       return F2CLOGICAL(A0);
  1105. #define XLONG          return A0;
  1106. #define XSHORT         return A0;
  1107. #define XVOID          return   ;
  1108. #if defined(vmsFortran) || defined(CRAYFortran)
  1109. #define XSTRING        return kill_trailing(                                   \
  1110.                                       kill_trailing(AA0,CFORTRAN_NON_CHAR),' ');
  1111. #else
  1112. #define XSTRING        return kill_trailing(                                   \
  1113.                                       kill_trailing( A0,CFORTRAN_NON_CHAR),' ');
  1114. #endif
  1115.  
  1116. #define CFFUN(NAME) __cf__/**/NAME
  1117.  
  1118. /* Note that we don't use LN here, but we keep it for consistency. */
  1119. #define CCALLSFFUN0(UN,LN) CFFUN(UN)()
  1120.  
  1121. #if defined(VAXC) && defined(vms)        /* Have avoided %CC-I-PARAMNOTUSED. */
  1122. #pragma standard
  1123. #endif
  1124.  
  1125. #define CCALLSFFUN1( UN,LN,T1,                        A1)         \
  1126.         CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
  1127. #define CCALLSFFUN2( UN,LN,T1,T2,                     A1,A2)      \
  1128.         CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
  1129. #define CCALLSFFUN3( UN,LN,T1,T2,T3,                  A1,A2,A3)   \
  1130.         CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
  1131. #define CCALLSFFUN4( UN,LN,T1,T2,T3,T4,               A1,A2,A3,A4)\
  1132.         CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
  1133. #define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5,            A1,A2,A3,A4,A5)          \
  1134.         CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
  1135. #define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6,         A1,A2,A3,A4,A5,A6)       \
  1136.         CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
  1137. #define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7,      A1,A2,A3,A4,A5,A6,A7)    \
  1138.         CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
  1139. #define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,   A1,A2,A3,A4,A5,A6,A7,A8) \
  1140.         CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
  1141. #define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
  1142.         CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
  1143.  
  1144. #define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
  1145. (ZCF(T1,1,A1) ZCF(T2,2,A2) ZCF(T3,3,A3) ZCF(T4,4,A4) ZCF(T5,5,A5)              \
  1146.  ZCF(T6,6,A6) ZCF(T7,7,A7) ZCF(T8,8,A8) ZCF(T9,9,A9) ZCF(TA,A,AA)              \
  1147.  (CFFUN(UN)(  BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \
  1148.               BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \
  1149.            SCF(T1,LN,1,A1) SCF(T2,LN,2,A2) SCF(T3,LN,3,A3) SCF(T4,LN,4,A4)     \
  1150.            SCF(T5,LN,5,A5) SCF(T6,LN,6,A6) SCF(T7,LN,7,A7) SCF(T8,LN,8,A8)     \
  1151.            SCF(T9,LN,9,A9) SCF(TA,LN,A,AA))))
  1152.  
  1153. /*  N.B. Create a separate function instead of using (call function, function
  1154. value here) because in order to create the variables needed for the input
  1155. arg.'s which may be const.'s one has to do the creation within {}, but these
  1156. can never be placed within ()'s. Therefore one must create wrapper functions.
  1157. gcc, on the other hand may be able to avoid the wrapper functions. */
  1158.  
  1159. /* Prototypes are needed to correctly handle the value returned correctly. N.B.
  1160. Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN
  1161. functions returning strings have extra arg.'s. Don't bother, since this only
  1162. causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn
  1163. for the same function in the same source code. Something done by the experts in
  1164. debugging only.*/    
  1165.  
  1166. #define PROTOCCALLSFFUN0(F,UN,LN)                                              \
  1167. PU/**/F( CFC_(UN,LN))(CF_NULL_PROTO);                                          \
  1168. static _INT(2,U,F,CFFUN(UN),0)() {E/**/F  _INT(3,GZ,F,UN,LN)); X/**/F}
  1169.  
  1170. #define PROTOCCALLSFFUN1( T0,UN,LN,T1)                                         \
  1171.         PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
  1172. #define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2)                                      \
  1173.         PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0)
  1174. #define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3)                                   \
  1175.         PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0)
  1176. #define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4)                                \
  1177.         PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0)
  1178. #define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5)                             \
  1179.         PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
  1180. #define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6)                          \
  1181.         PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
  1182. #define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7)                       \
  1183.         PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
  1184. #define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)                    \
  1185.         PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
  1186. #define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)                 \
  1187.         PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
  1188.  
  1189. #ifndef __CF__KnR
  1190. #define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)              \
  1191. PU/**/T0(CFC_(UN,LN))(CF_NULL_PROTO);                                          \
  1192. static _INT(2,U,T0,CFFUN(UN),0)(UCF(T1,1,0) UCF(T2,2,1) UCF(T3,3,1) UCF(T4,4,1)  \
  1193.    UCF(T5,5,1) UCF(T6,6,1) UCF(T7,7,1) UCF(T8,8,1) UCF(T9,9,1) UCF(TA,A,1)     \
  1194.                          HCF(T1,1) HCF(T2,2) HCF(T3,3) HCF(T4,4) HCF(T5,5)     \
  1195.                          HCF(T6,6) HCF(T7,7) HCF(T8,8) HCF(T9,9) HCF(TA,A) )   \
  1196. {VCF(T1,1) VCF(T2,2) VCF(T3,3) VCF(T4,4) VCF(T5,5)                             \
  1197.  VCF(T6,6) VCF(T7,7) VCF(T8,8) VCF(T9,9) VCF(TA,A) E/**/T0                     \
  1198.  CCF(T1,1) CCF(T2,2) CCF(T3,3) CCF(T4,4) CCF(T5,5)                             \
  1199.  CCF(T6,6) CCF(T7,7) CCF(T8,8) CCF(T9,9) CCF(TA,A)                             \
  1200.  _INT(3,G,T0,UN,LN)CCCF(T1,1,0) CCCF(T2,2,1) CCCF(T3,3,1) CCCF(T4,4,1) CCCF(T5,5,1)\
  1201.                  CCCF(T6,6,1) CCCF(T7,7,1) CCCF(T8,8,1) CCCF(T9,9,1) CCCF(TA,A,1)\
  1202.                JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5)               \
  1203.                JCF(T6,6) JCF(T7,7) JCF(T8,8) JCF(T9,9) JCF(TA,A));             \
  1204.  WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5)              \
  1205.  WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,A) X/**/T0}
  1206. #else
  1207. #define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)              \
  1208. PU/**/T0(CFC_(UN,LN))(CF_NULL_PROTO);                                          \
  1209. static _INT(2,U,T0,CFFUN(UN),0)(UUCF(T1,1,0) UUCF(T2,2,1) UUCF(T3,3,1) UUCF(T4,4,1)  \
  1210.     UUCF(T5,5,1) UUCF(T6,6,1) UUCF(T7,7,1) UUCF(T8,8,1) UUCF(T9,9,1) UUCF(TA,A,1)  \
  1211.                        HHCF(T1,1) HHCF(T2,2) HHCF(T3,3) HHCF(T4,4) HHCF(T5,5)  \
  1212.                        HHCF(T6,6) HHCF(T7,7) HHCF(T8,8) HHCF(T9,9) HHCF(TA,A)) \
  1213.  UUUCF(T1,1,0) UUUCF(T2,2,1) UUUCF(T3,3,1) UUUCF(T4,4,1) UUUCF(T5,5,1)         \
  1214.  UUUCF(T6,6,1) UUUCF(T7,7,1) UUUCF(T8,8,1) UUUCF(T9,9,1) UUUCF(TA,A,1)         \
  1215.            HHHCF(T1,1) HHHCF(T2,2) HHHCF(T3,3) HHHCF(T4,4) HHHCF(T5,5)         \
  1216.            HHHCF(T6,6) HHHCF(T7,7) HHHCF(T8,8) HHHCF(T9,9) HHHCF(TA,A);        \
  1217. {VCF(T1,1) VCF(T2,2) VCF(T3,3) VCF(T4,4) VCF(T5,5)                             \
  1218.  VCF(T6,6) VCF(T7,7) VCF(T8,8) VCF(T9,9) VCF(TA,A) E/**/T0                     \
  1219.  CCF(T1,1) CCF(T2,2) CCF(T3,3) CCF(T4,4) CCF(T5,5)                             \
  1220.  CCF(T6,6) CCF(T7,7) CCF(T8,8) CCF(T9,9) CCF(TA,A)                             \
  1221.  _INT(3,G,T0,UN,LN)CCCF(T1,1,0) CCCF(T2,2,1) CCCF(T3,3,1) CCCF(T4,4,1) CCCF(T5,5,1)\
  1222.                  CCCF(T6,6,1) CCCF(T7,7,1) CCCF(T8,8,1) CCCF(T9,9,1) CCCF(TA,A,1)\
  1223.                JCF(T1,1) JCF(T2,2) JCF(T3,3) JCF(T4,4) JCF(T5,5)               \
  1224.                JCF(T6,6) JCF(T7,7) JCF(T8,8) JCF(T9,9) JCF(TA,A) );            \
  1225.  WCF(T1,A1,1) WCF(T2,A2,2) WCF(T3,A3,3) WCF(T4,A4,4) WCF(T5,A5,5)              \
  1226.  WCF(T6,A6,6) WCF(T7,A7,7) WCF(T8,A8,8) WCF(T9,A9,9) WCF(TA,AA,A) X/**/T0}
  1227. #endif
  1228.  
  1229. /*-------------------------------------------------------------------------*/
  1230.  
  1231. /*               UTILITIES FOR FORTRAN TO CALL C ROUTINES                  */
  1232.  
  1233. #if defined(VAXC) && defined(vms)        /* To avoid %CC-I-PARAMNOTUSED. */
  1234. #pragma nostandard
  1235. #endif
  1236.  
  1237. #if defined(vmsFortran) || defined(CRAYFortran)
  1238. #define   DCF(TN,I)
  1239. #define  DDCF(TN,I)
  1240. #define DDDCF(TN,I)
  1241. #else
  1242. #define   DCF                HCF
  1243. #define  DDCF               HHCF
  1244. #define DDDCF              HHHCF
  1245. #endif
  1246.  
  1247. #define QCF(TN,I)    STR_/**/TN(1,Q,B/**/I, 0,0,0)
  1248. #define QLOGICAL( B)
  1249. #define QPLOGICAL(B)
  1250. #ifdef vmsFortran
  1251. #define QSTRINGV( B) char *B;
  1252. #else
  1253. #define QSTRINGV( B) char *B; unsigned int B/**/N;
  1254. #endif
  1255. #define QSTRING(  B) char *B=NULL;
  1256. #define QPSTRING( B) char *B=NULL;
  1257. #define QPSTRINGV    QSTRINGV
  1258.  
  1259. #define TCF(NAME,TN,I,M)   _SEP_(TN,M,COMMA) T/**/TN(NAME,A/**/I,B/**/I,C/**/I)
  1260. #define TBYTE(    M,A,B,D) *A
  1261. #define TDOUBLE(  M,A,B,D) *A
  1262. #define TFLOAT(   M,A,B,D) *A
  1263. #define TINT(     M,A,B,D) *A
  1264. #define TLOGICAL( M,A,B,D)  F2CLOGICAL(*A)
  1265. #define TLONG(    M,A,B,D) *A
  1266. #define TSHORT(   M,A,B,D) *A
  1267. #define TBYTEV(   M,A,B,D)  A
  1268. #define TDOUBLEV( M,A,B,D)  A
  1269. #define TFLOATV(  M,A,B,D)  VOIDP A
  1270. #define TINTV(    M,A,B,D)  A
  1271. #define TLOGICALV(M,A,B,D)  A
  1272. #define TLONGV(   M,A,B,D)  A
  1273. #define TSHORTV(  M,A,B,D)  A
  1274. #define TBYTEVV(  M,A,B,D)  A
  1275. #define TDOUBLEVV(M,A,B,D)  A
  1276. #define TFLOATVV( M,A,B,D)  VOIDP A
  1277. #define TINTVV(   M,A,B,D)  A
  1278. #define TLOGICALVV(M,A,B,D) A
  1279. #define TLONGVV(  M,A,B,D)  A
  1280. #define TSHORTVV( M,A,B,D)  A
  1281. #define TPBYTE(   M,A,B,D)  A
  1282. #define TPDOUBLE( M,A,B,D)  A
  1283. #define TPFLOAT(  M,A,B,D)  VOIDP A
  1284. #define TPINT(    M,A,B,D)  A
  1285. #define TPLOGICAL(M,A,B,D)  ((*A=F2CLOGICAL(*A)),A)
  1286. #define TPLONG(   M,A,B,D)  A
  1287. #define TPSHORT(  M,A,B,D)  A
  1288. #define TPVOID(   M,A,B,D)  A
  1289. #ifdef vmsFortran
  1290. #define TSTRING(  M,A,B,D) (!*(int *)A->dsc$a_pointer)?NULL:\
  1291. memchr(A->dsc$a_pointer,'\0',A->dsc$w_length)?A->dsc$a_pointer:\
  1292.                           ((B=malloc(A->dsc$w_length+1))[A->dsc$w_length]='\0',\
  1293.                   kill_trailing(memcpy(B,A->dsc$a_pointer,A->dsc$w_length),' '))
  1294. #define TSTRINGV( M,A,B,D)                                                     \
  1295.  (B=malloc((A->dsc$w_length+1)*A->dsc$l_m[0]), (void *)F2CSTRVCOPY(B,A))
  1296. #else
  1297. #ifdef CRAYFortran
  1298. #define TSTRING(  M,A,B,D) (!*(int *)_fcdtocp(A))?NULL:\
  1299. memchr(_fcdtocp(A),'\0',_fcdlen(A))?_fcdtocp(A):\
  1300.                           ((B=malloc(_fcdlen(A)+1))[_fcdlen(A)]='\0',          \
  1301.                             kill_trailing(memcpy(B,_fcdtocp(A),_fcdlen(A)),' '))
  1302. #define TSTRINGV( M,A,B,D) (B/**/N=num_elem(_fcdtocp(A),_fcdlen(A),M/**/_STRV_/**/A),             \
  1303.      (void *)vkill_trailing(f2cstrv(_fcdtocp(A),B=malloc(B/**/N*(_fcdlen(A)+1)),_fcdlen(A)+1,B/**/N*(_fcdlen(A)+1)),\
  1304.                             _fcdlen(A)+1,B/**/N*(_fcdlen(A)+1),' '))
  1305. #else
  1306. #define TSTRING(  M,A,B,D) (!*(int *)A)?NULL: memchr(A,'\0',D)?A:              \
  1307.                      (memcpy(B=malloc(D+1),A,D),B[D]='\0', kill_trailing(B,' '))
  1308. #define TSTRINGV( M,A,B,D) (B/**/N=num_elem(A,D,M/**/_STRV_/**/A),             \
  1309.      (void *)vkill_trailing(f2cstrv(A,B=malloc(B/**/N*(D+1)),D+1,B/**/N*(D+1)),\
  1310.                             D+1,B/**/N*(D+1),' '))
  1311. #endif
  1312. #endif
  1313. #define TPSTRING            TSTRING
  1314. #define TPSTRINGV           TSTRINGV
  1315. #define TCF_0(    M,A,B,D)
  1316.  
  1317. #define RCF(TN,I)        STR_/**/TN(3,R,A/**/I,B/**/I,C/**/I,0)
  1318. #define RLOGICAL( A,B,D)
  1319. #define RPLOGICAL(A,B,D) *A=C2FLOGICAL(*A);
  1320. #define RSTRING(  A,B,D) if (B) free(B);
  1321. #define RSTRINGV( A,B,D) free(B);
  1322. #ifdef vmsFortran
  1323. #define RPSTRING( A,B,D) if (B)                                              \
  1324.  memcpy(A->dsc$a_pointer,B,MIN(strlen(B),A->dsc$w_length)),                    \
  1325.  (A->dsc$w_length>strlen(B)?                                                   \
  1326.    memset(A->dsc$a_pointer+strlen(B),' ', A->dsc$w_length-strlen(B)):0),free(B);
  1327. #define RPSTRINGV(A,B,D) C2FSTRVCOPY(B,A), free(B);
  1328. #else
  1329. #ifdef CRAYFortran
  1330. #define RPSTRING( A,B,D) if (B)                                              \
  1331.  memcpy(_fcdtocp(A),B,MIN(strlen(B),_fcdlen(A))),  (_fcdlen(A)>strlen(B)?      \
  1332.    memset(_fcdtocp(A)+strlen(B),' ', _fcdlen(A)-strlen(B)):0),free(B);
  1333. #define RPSTRINGV(A,B,D)                                                     \
  1334.              c2fstrv(B,_fcdtocp(A),_fcdlen(A)+1,(_fcdlen(A)+1)*B/**/N), free(B);
  1335. #else
  1336. #define RPSTRING( A,B,D) if (B) memcpy(A,B,MIN(strlen(B),D)),                \
  1337.                   (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), free(B);
  1338. #define RPSTRINGV(A,B,D) c2fstrv(B,A,D+1,(D+1)*B/**/N), free(B);
  1339. #endif
  1340. #endif
  1341.  
  1342. #define FZBYTE(   UN,LN) INTEGER_BYTE     fcallsc(UN,LN)(
  1343. #define FZDOUBLE( UN,LN) DOUBLE_PRECISION fcallsc(UN,LN)(
  1344. #define FZINT(    UN,LN) int   fcallsc(UN,LN)(
  1345. #define FZLOGICAL(UN,LN) int   fcallsc(UN,LN)(
  1346. #define FZLONG(   UN,LN) long  fcallsc(UN,LN)(
  1347. #define FZSHORT(  UN,LN) short fcallsc(UN,LN)(
  1348. #define FZVOID(   UN,LN) void  fcallsc(UN,LN)(
  1349. #ifndef __CF__KnR
  1350. /* The void is req'd by the Apollo, to make this an ANSI function declaration.
  1351.    The Apollo promotes K&R float functions to double. */
  1352. #define FZFLOAT(  UN,LN) float fcallsc(UN,LN)(void
  1353. #ifdef vmsFortran
  1354. #define FZSTRING( UN,LN) void  fcallsc(UN,LN)(fstring *AS
  1355. #else
  1356. #ifdef CRAYFortran
  1357. #define FZSTRING( UN,LN) void  fcallsc(UN,LN)(_fcd     AS
  1358. #else
  1359. #define FZSTRING( UN,LN) void  fcallsc(UN,LN)(char    *AS, unsigned D0
  1360. #endif
  1361. #endif
  1362. #else
  1363. #ifndef sunFortran
  1364. #define FZFLOAT(  UN,LN) float fcallsc(UN,LN)(
  1365. #else
  1366. #define FZFLOAT(  UN,LN) FLOATFUNCTIONTYPE fcallsc(UN,LN)(
  1367. #endif
  1368. #if defined(vmsFortran) || defined(CRAYFortran)
  1369. #define FZSTRING( UN,LN) void  fcallsc(UN,LN)(AS
  1370. #else
  1371. #define FZSTRING( UN,LN) void  fcallsc(UN,LN)(AS, D0
  1372. #endif
  1373. #endif
  1374.  
  1375. #define FBYTE            FZBYTE
  1376. #define FDOUBLE          FZDOUBLE
  1377. #ifndef __CF_KnR
  1378. #define FFLOAT(  UN,LN)  float   fcallsc(UN,LN)(
  1379. #else
  1380. #define FFLOAT           FZFLOAT
  1381. #endif
  1382. #define FINT             FZINT
  1383. #define FLOGICAL         FZLOGICAL
  1384. #define FLONG            FZLONG
  1385. #define FSHORT           FZSHORT
  1386. #define FVOID            FZVOID
  1387. #define FSTRING(  UN,LN) FZSTRING(UN,LN),
  1388.  
  1389. #define FFINT
  1390. #define FFVOID
  1391. #ifdef vmsFortran
  1392. #define FFSTRING          fstring *AS; 
  1393. #else
  1394. #ifdef CRAYFortran
  1395. #define FFSTRING          _fcd     AS;
  1396. #else
  1397. #define FFSTRING          char    *AS; unsigned D0;
  1398. #endif
  1399. #endif
  1400.  
  1401. #define LINT              A0=
  1402. #define LSTRING           A0=
  1403. #define LVOID                        
  1404.  
  1405. #define KINT            
  1406. #define KVOID
  1407. /* KSTRING copies the string into the position provided by the caller. */
  1408. #ifdef vmsFortran
  1409. #define KSTRING                                                                \
  1410.  memcpy(AS->dsc$a_pointer,A0, MIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))) ); \
  1411.  AS->dsc$w_length>(A0==NULL?0:strlen(A0))?                                     \
  1412.   memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ',                        \
  1413.          AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0;
  1414. #else
  1415. #ifdef CRAYFortran
  1416. #define KSTRING                                                                \
  1417.  memcpy(_fcdtocp(AS),A0, MIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) );           \
  1418.  _fcdlen(AS)>(A0==NULL?0:strlen(A0))?                                          \
  1419.   memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ',                             \
  1420.          _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0;
  1421. #else
  1422. #define KSTRING          memcpy(AS,A0, MIN(D0,(A0==NULL?0:strlen(A0))) );      \
  1423.                  D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \
  1424.                                             ' ', D0-(A0==NULL?0:strlen(A0))):0;
  1425. #endif
  1426. #endif
  1427.  
  1428. /* Note that K.. and I.. can't be combined since K.. has to access data before
  1429. R.., in order for functions returning strings which are also passed in as
  1430. arguments to work correctly. Note that R.. frees and hence may corrupt the
  1431. string. */
  1432. #define IBYTE          return A0;
  1433. #define IDOUBLE        return A0;
  1434. #ifndef sunFortran
  1435. #define IFLOAT         return A0;
  1436. #else
  1437. #define IFLOAT         RETURNFLOAT(A0);
  1438. #endif
  1439. #define IINT           return A0;
  1440. #define ILOGICAL       return C2FLOGICAL(A0);
  1441. #define ILONG          return A0;
  1442. #define ISHORT         return A0;
  1443. #define ISTRING        return   ;
  1444. #define IVOID          return   ;
  1445.  
  1446. #if defined(VAXC) && defined(vms)        /* Have avoided %CC-I-PARAMNOTUSED. */
  1447. #pragma standard
  1448. #endif
  1449.  
  1450. #define FCALLSCSUB0( CN,UN,LN)             FCALLSCFUN0(VOID,CN,UN,LN)
  1451. #define FCALLSCSUB1( CN,UN,LN,T1)          FCALLSCFUN1(VOID,CN,UN,LN,T1)
  1452. #define FCALLSCSUB2( CN,UN,LN,T1,T2)       FCALLSCFUN2(VOID,CN,UN,LN,T1,T2)
  1453. #define FCALLSCSUB3( CN,UN,LN,T1,T2,T3)    FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3)
  1454. #define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4)
  1455. #define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5)                \
  1456.     FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5)
  1457. #define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6)             \
  1458.     FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6)       
  1459. #define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)          \
  1460.     FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)
  1461. #define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)       \
  1462.     FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)
  1463. #define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)    \
  1464.     FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)
  1465. #define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
  1466.    FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)
  1467.  
  1468. #define FCALLSCFUN1( T0,CN,UN,LN,T1)            \
  1469.         FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
  1470. #define FCALLSCFUN2( T0,CN,UN,LN,T1,T2)         \
  1471.         FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0)
  1472. #define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3)      \
  1473.         FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0)
  1474. #define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4)   \
  1475.         FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0)
  1476. #define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5)\
  1477.         FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
  1478. #define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6)          \
  1479.         FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
  1480. #define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)       \
  1481.         FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
  1482. #define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)    \
  1483.         FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
  1484. #define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
  1485.         FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
  1486.  
  1487. #ifndef __CF__KnR
  1488. #define FCALLSCFUN0(T0,CN,UN,LN)                                               \
  1489. FZ/**/T0(UN,LN)) {_INT(2,U,T0,A0,0); _INT(0,L,T0,0,0) CN(); _INT(0,K,T0,0,0) I/**/T0}
  1490.  
  1491. #define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)                \
  1492. F/**/T0(UN,LN)NCF(T1,1,0) NCF(T2,2,1) NCF(T3,3,1) NCF(T4,4,1) NCF(T5,5,1)      \
  1493.               NCF(T6,6,1) NCF(T7,7,1) NCF(T8,8,1) NCF(T9,9,1) NCF(TA,A,1)      \
  1494.                         DCF(T1,1) DCF(T2,2) DCF(T3,3) DCF(T4,4) DCF(T5,5)      \
  1495.                         DCF(T6,6) DCF(T7,7) DCF(T8,8) DCF(T9,9) DCF(TA,A) )    \
  1496.  {_INT(2,U,T0,A0,0); QCF(T1,1) QCF(T2,2) QCF(T3,3) QCF(T4,4) QCF(T5,5)           \
  1497.                QCF(T6,6) QCF(T7,7) QCF(T8,8) QCF(T9,9) QCF(TA,A)               \
  1498.  _INT(0,L,T0,0,0) CN(TCF(LN,T1,1,0) TCF(LN,T2,2,1) TCF(LN,T3,3,1) TCF(LN,T4,4,1) \
  1499.     TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) TCF(LN,T8,8,1) TCF(LN,T9,9,1) \
  1500.     TCF(LN,TA,A,1)); _INT(0,K,T0,0,0) RCF(T1,1) RCF(T2,2) RCF(T3,3) RCF(T4,4)    \
  1501.            RCF(T5,5) RCF(T6,6) RCF(T7,7) RCF(T8,8) RCF(T9,9) RCF(TA,A) I/**/T0}
  1502. #else
  1503. #define FCALLSCFUN0(T0,CN,UN,LN) FZ/**/T0(UN,LN)) _INT(0,FF,T0,0,0)              \
  1504. {_INT(2,U,T0,A0,0); _INT(0,L,T0,0,0) CN(); _INT(0,K,T0,0,0) I/**/T0}
  1505.  
  1506. #define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)                \
  1507. F/**/T0(UN,LN)NNCF(T1,1,0) NNCF(T2,2,1) NNCF(T3,3,1) NNCF(T4,4,1) NNCF(T5,5,1) \
  1508.               NNCF(T6,6,1) NNCF(T7,7,1) NNCF(T8,8,1) NNCF(T9,9,1) NNCF(TA,A,1) \
  1509.    DDCF(T1,1) DDCF(T2,2) DDCF(T3,3) DDCF(T4,4) DDCF(T5,5)                      \
  1510.    DDCF(T6,6) DDCF(T7,7) DDCF(T8,8) DDCF(T9,9) DDCF(TA,A) )  _INT(0,FF,T0,0,0)   \
  1511.  NNNCF(T1,1,0) NNNCF(T2,2,1) NNNCF(T3,3,1) NNNCF(T4,4,1) NNNCF(T5,5,1)         \
  1512.  NNNCF(T6,6,1) NNNCF(T7,7,1) NNNCF(T8,8,1) NNNCF(T9,9,1) NNNCF(TA,A,1)         \
  1513.  DDDCF(T1,1) DDDCF(T2,2) DDDCF(T3,3) DDDCF(T4,4) DDDCF(T5,5)                   \
  1514.  DDDCF(T6,6) DDDCF(T7,7) DDDCF(T8,8) DDDCF(T9,9) DDDCF(TA,A);                  \
  1515.  {_INT(2,U,T0,A0,0); QCF(T1,1) QCF(T2,2) QCF(T3,3) QCF(T4,4) QCF(T5,5)           \
  1516.                QCF(T6,6) QCF(T7,7) QCF(T8,8) QCF(T9,9) QCF(TA,A)               \
  1517.  _INT(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) TCF(LN,T3,3,1)               \
  1518.                     TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1)               \
  1519.      TCF(LN,T7,7,1) TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,A,1));             \
  1520.  _INT(0,K,T0,0,0) RCF(T1,1) RCF(T2,2) RCF(T3,3) RCF(T4,4) RCF(T5,5)              \
  1521.                 RCF(T6,6) RCF(T7,7) RCF(T8,8) RCF(T9,9) RCF(TA,A) I/**/T0}
  1522. #endif
  1523.  
  1524. #endif   /* VAX VMS or Ultrix, Mips, CRAY, Sun, Apollo, HP9000, LynxOS, IBMR2.
  1525.             f2c, NAG f90. */
  1526. #endif     /* __CFORTRAN_LOADED */
  1527.